Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/STRAOB/MISCCORE.INC

Text File | 1995-02-24 | 46KB | 1,845 lines

{section  AddBackSlash }
Function  AddBackSlash(s1 : string) : string;
var s : string;
     begin
     if (length(s1) > 0) and (s1[length(s1)] <> '\') then
          s := s1 + '\'
     else s := s1;
     AddBackSlash := s;
     end;


{section  BooleanStr }
Function  BooleanStr( B : boolean ) : string;
    begin
    if B then
         BooleanStr := 'YES'
    else BooleanStr := 'NO ';
    end;


{section  BreakLine }
Function  BreakLine(var s : string; bklen : integer) : string;
var s1 : string;
    ll  : integer;
    alldone : boolean;
     begin
     RemoveTrailing(s,' ');
     s1 := s;
     if length(s) > bklen then
          begin
          ll := bklen;
          alldone := false;
          while (ll > 0) and not alldone do
               begin
               if      s[ll] = ' ' then alldone := true
               else if s[ll] = ',' then alldone := true
               else dec(ll);
               end;
          if ll > 1 then
               begin
               s1 := copy(s,1,ll);
               delete(s,1,ll);
               end
          else begin
               s1 := copy(s,1,bklen);
               delete(s,1,bklen);
               end;
          end
     else s := '';
     Breakline := s1;
     end;


{section  BreakLineChr }
Function  BreakLineChr(var s : string; bklen : integer; ch : char) : string;
var s1 : string;
    ll  : integer;
    done : boolean;
     begin
     RemoveTrailing(s,' ');
     s1 := s;
     if length(s) > bklen then
          begin
          ll := bklen;
          done := false;
          while (ll > 0) and not done do
               begin
               if      s[ll] = ch then done := true
               else dec(ll);
               end;
          if ll > 1 then
               begin
               s1 := copy(s,1,ll);
               delete(s,1,ll);
               end
          else begin
               s1 := copy(s,1,bklen);
               delete(s,1,bklen);
               end;
          end
     else s := '';
     BreakLineChr := s1;
     end;


{SECTION Buf16ToHexStr }
Function Buf16ToHexStr(addr : longint; count : integer; var xbuf; flag : boolean) : string;
            {[STRING] One line of the DUMP output}
var s,asc : string;
    i,j   : integer;
    buf   : array[1..16] of byte;
     begin
     s := ''; asc := '';
     move(xbuf,buf,16);
     j := 16;
     if count < 16 then j := count;
     if count < 1  then j := 1;
     for i := 1 to j do
          begin
          s := s + ByteToHex(buf[i]) + ' ';
          if buf[i] > 31 then asc := asc + chr(buf[i])
          else asc := asc + '.';
          end;
     Buf16ToHexStr := FmtAddress(addr,6,flag)+': '+ leftstr(s,48) +
                                 ' | ' + asc;
     end;


{section  ByteToHex }
Function  ByteToHex( B : byte) : string;
var s : string[2];
    b1 : byte;
     begin
     s := '00';
     b1 := (b and $F0) div 16;
     if b1 < 10 then s[1] := chr(b1+48)
     else s[1] := chr(b1+55);
     b1 := b and $0F;
     if b1 < 10 then s[2] := chr(b1+48)
     else s[2] := chr(b1+55);
     ByteToHex := s;
     end;


{section  CheckSectionID }
Function  CheckSectionID(s,secttag : string) : string;
                        {[STRING] checks line s, returning section name if this is a section line }
var s1,s2 : string;
     begin
     s1 := '';
     if CompareUpL(s,secttag,length(secttag)) then
          begin
          s2 := s;
          delete(s2,1,length(secttag));
          trim(s2);
          s1 := GetLeftStr(s2,' ');
          end;
     CheckSectionID := s1;
     end;


{section CenterStr }
Function CenterStr(s : string; w : byte) : string;
{ Centers a string in a field of specified width }
var NewStr : string;
    i       : word;
    p       : word;
     begin
     FillChar(NewStr, SizeOf(NewStr), ' ');
     NewStr[0] := CHR(w);
     p         := (w - length(s)) SHR 1;
     for i := 1 to length(s) do NewStr[p + i] := s[i];
     CenterStr := NewStr
     end;


{section ChangeDir }
Function ChangeDir(dirname : string) : boolean;
                 {[FILE] does CD <dir> command (if a filename is provided, goes to dir)}
var fn    : string;
    j,err : integer;
     begin
     j := pos('.',dirname);
     if j > 0 then
          fn := DeleteBackSlash(FilePathStr(dirname))
     else fn := DeleteBackSlash(dirname);
     writeln('ChangeDir [',fn,']');
     {$I-} ChDir(fn); {$I+}
     err := IOResult;
     if err <> 0 then writeln('ChangeDir failed ',err);
     ChangeDir := (err = 0);
     end;




{SECTION  CheckYesNo }
Function  CheckYesNo(pr : string; default : char) : boolean;
var s : string[1];
     begin
     write(pr);
     if UpCase(default) = 'Y' then
          write(' (Y/n) ')
     else write(' (y/N) ');
     readln(s);
     if s = '' then s := default;
     s := UpCaseStr(s);
     writeln('[',s,']');
     if s = 'N' then
          CheckYesNo := false
     else CheckYesNo := true;
     end;



{section CompareBUFS }
Function CompareBUFS(var rec1,rec2; size : integer) : boolean;
                  {[MISC] Lifted almost exactly from TPC Language Guide }
type TBytes = array[0..65534] of byte;
var  N      : word;
     begin
     N := 0;
     while (N < size) and ( TBytes(rec2)[N] = TBytes(rec1)[N]) do inc(N);
     CompareBUFS := ( N = size );
     end;



{SECTION  Compare }
Function  Compare(s1,s2 :string) : boolean;
                        {[STRING] Compares s1 to s2 - s2 can have wildcards }
var i    : integer;
    done : boolean;
    ch   : char;
     begin
    { writeln('Compare  [',s1,'] [',s2,']');}
     Compare := true; i := 0; done := false;
     while (i < length(s2)) and not done do
          begin
          inc(i);
          ch := s2[i];
          case ch of
               '?'   : begin end;   {match fine}
               '*'   : begin Compare := true; done := true; end;
               else    begin
                       if s1[i] <> ch then
                            begin
                           { writeln('char ',i,' ',s1[i],' ',ch); }
                            Compare := false;
                            done := true;
                            end;
                       end;
               end;
          end;
     if not done and (i <> length(s1)) then
          begin
         { writeln('ending ',i,' ',length(s1)); }
          Compare := false;
          end;
     end;


{SECTION  CompareTrim }
Function  CompareTrim(s1,s2 :string) : boolean;
                        {[STRING] Compares s1 to s2, trims first }
     begin
     CompareTrim := Compare(trimstr(s1),trimstr(s2));
     end;


{SECTION  CompareL }
Function  CompareL(s1,s2 :string; len : integer) : boolean;
                        {[STRING] Compares s1 to s2 for length len }
     begin
     CompareL := Compare(leftstr(s1,len),leftstr(s2,len));
     end;


{SECTION  CompareUpL }
Function  CompareUpL(s1,s2 :string; len : integer) : boolean;
                        {[STRING] Compares s1 to s2 for length len (s1,s2 shifted UP)}
     begin
     CompareUpL := Compare(UpCaseStr(leftstr(s1,len)),
                           UpCaseStr(leftstr(s2,len)));
     end;


{section  CompareStrs }
Function  CompareStrs(s1,s2 : string; compmode,casemode : integer) : boolean;
          {[STRING] - comprehensive string comparisons, NO WildCards }
var ok : boolean;
    st1, st2 : string;
     begin
     ok := true;
     st1 := s1; if casemode = UpCaseMode then st1 := UpCaseStr(s1);
     st2 := s2; if casemode = UpCaseMode then st2 := UpCaseStr(s2);
     case compmode of
         EQmode : if (st1  <>  st2) then ok := false;
         GEmode : if (st1  <   st2) then ok := false;
         LEmode : if (st1  >   st2) then ok := false;
         GTmode : if (st1  <   st2) then ok := false;
         LTmode : if (st1  >   st2) then ok := false;
         end;
     CompareStrs := ok;
     end;


{section  CompareStrsEQ }
Function  CompareStrsEQ(s1,s2 : string; casemode : integer) : boolean;
          {[STRING] - string comparisons, NO WildCards, EQ only }
var st1, st2 : string[80];
     begin
     if casemode = UpCaseMode then
          st1 := UpCaseStr(s1)
     else st1 := s1;
     if casemode = UpCaseMode then
          st2 := UpCaseStr(s2)
     else st2 := s2;
     CompareStrsEQ := (st1 = st2);
     end;


{section CompressStr }
Function CompressStr(s1 : string) : string;
var ls,j,rc : integer;
    s,s2    : string;
    ch      : char;
    begin
     S := S1;
    ls := length(s);
    if ls < 3 then
        begin
        CompressStr := s;
        exit;
        end;
    s2 := '';
    j := 1;
    while j <= ls  do
        begin
        if (j > (ls-2)) or (s[j] <> s[j+1]) or (s[j] <> s[j+2]) then
            s2 := s2 + s[j]
        else
            begin
            ch := s[j];
            inc(j);
            rc := 0;
            s2 := s2 + s[j];
            while (j <= ls) and (s[j] = ch) do
                begin
                inc(rc);
                inc(j);
                end;
            s2 := s2 + chr(160+rc);
            if j <= ls then s2 := s2 + s[j];
            end;
        inc(j);
        end;
    CompressStr := s2;
    end;


{section  ConstStr }
Function  ConstStr(C : Char; N : Integer) : string;
var S : string;
    begin
    if N < 0 then N := 0;
    S[0] := Chr(N);
    FillChar(S[1],N,C);
    ConstStr := s;
    end;



{section  CopyRemove }
Function  CopyRemove(var s : string; f,l : integer) : string;
                            {[STRING] copies then deletes a substring }
var len : integer;
     begin
     CopyRemove := '';
     if (f > 0) and (f <= l) and (l <= length(s)) then
          begin
          len := (l - f) + 1;
          CopyRemove := copy(s,f,len);
          delete(s,f,len);
          end;
     end;


{section  CurrDTimeString }
Function  CurrDTimeString : string;
    var
        temp1,temp2       : string;
        Yr, Mo, Da, dow   : word;
        Hr, Mn, Sc, sc100 : word;
        i                 : integer;
        l                 : longint;
    begin
    GetDate(yr,mo,da,dow);
    l := (yr-1900)*tenthousand + mo*onehundred +da;
    str(l:6,temp1);
    GetTime(hr,mn,sc,sc100);
    l := hr*tenthousand + mn*onehundred +sc;
    str(l:6,temp2);
    for i := 1 to 6 do
        begin
        if temp1[i] = ' ' then temp1[i] := '0';
        if temp2[i] = ' ' then temp2[i] := '0';
        end;
    CurrDTimeString := temp1+temp2;
    end;


{section  DefaultDriveStr }
Function  DefaultDriveStr : string;
var s : string;
    begin
    GetDir(0,s);
    DefaultDriveStr := s;
    end;


{section  DeleteBackSlash }
Function  DeleteBackSlash(s1 : string) : string;
var s : string;
     begin
     if (length(s1) > 0) and (s1[length(s1)] = '\') then
          s := copy(s1,1,length(s1)-1)
     else s := s1;
     DeleteBackSlash := s;
     end;


{section DirExists }
Function DirExists(dirname : string) : boolean;
                 {[FILE] sees if directory exists (a full file name may be provided)}
var fn : string;
    j  : integer;
     begin
     j := pos('.',dirname);
     if j > 0 then fn := AddBackSlash(FilePathStr(dirname)) + '.'
     else fn := AddBackslash(dirname)+'.';
     DirExists := fileexists(fn);
     end;


{section DirExistsMSG }
Function DirExistsMSG(dirname,yesmsg,nomsg : string) : boolean;
                 {[FILE] sees if directory exists (a full file name may be provided)}
var ok : boolean;
     begin
     ok := DirExists(dirname);
     if ok and (yesmsg <> '') then
          writeln('Directory exists [',dirname,'].  ',yesmsg)
     else if not ok and (nomsg <> '') then
          writeln('Directory does not exist [',dirname,'].  ',nomsg);
     DirExistsMSG := ok;
     end;


{section  DirTag }
Function  DirTag(path : string) : string;
var s : string;
    i : integer;
     begin
     s := path;
     i := pos('\',s);
     while i > 0 do
          begin
          delete(s,1,i);
          i := pos('\',s);
          end;
     Dirtag := s;
     end;


{section DnCaseStr }
Function DnCaseStr(s : string) : string;
{ Converts a string to lower case characters }
var i : integer;
    b : byte;
     begin
     for i := 1 to length(s) do
          begin
          b := ord(s[i]);
          if (b > 64) and (b < 91) then s[i] := chr(b+32);
          end;
     DnCaseStr := s;
     end;


{section DollarStr }
Function DollarStr( R : real; L : integer ) : string;
var S : string;
    begin
    S := '';
    case L of
        4..15  : Str(R:L:2,S);
        else     S := ConstStr('*',L);
        end;
    DollarStr := s;
end;



{section  DOSErrStr }
Function  DOSErrStr(err : integer) : string;
     begin
     DOSErrStr := 'DOS Error ('+integerstr(err,4)+')';
     end;


{section  DOSErrStrBig }
Function  DOSErrStrBig(err : integer) : string;
{ DOS file error returns - eliminated 10/2/94 - too big}
var s : string;
     begin
     case err of
         0        : s :=  'ok ' ;
         1        : s :=  'Invalid function number' ;
         2        : s :=  'file not found' ;
         3        : s :=  'Path not found' ;
         4        : s :=  'Too many open files' ;
         5        : s :=  'File access denied' ;
         6        : s :=  'Invalid file handle' ;
         12       : s :=  'Invalid file access code' ;
         15       : s :=  'Invalid drive number' ;
         18       : s :=  'No More files' ;
         100      : s :=  'Disk read error' ;
         101      : s :=  'Disk write error' ;
         102      : s :=  'File not assigned' ;
         103      : s :=  'File not open' ;
         104      : s :=  'File not opened for input' ;
         105      : s :=  'File not opened for output' ;
         150      : s :=  'Disk is write protected' ;
         152      : s :=  'drive not ready' ;
         159      : s :=  'Printer out of paper' ;
         160      : s :=  'Device write fault' ;
         162      : s :=  'Hardware failure' ;
         200      : s :=  'Division by zero' ;
         201      : s :=  'Range check' ;
         202      : s :=  'Stack overflow' ;
         203      : s :=  'Heap overflow' ;
         204      : s :=  'Invalid pointer operation' ;
         205..207 : s := 'Floating point problem' ;
         208..209 : s := 'Overlay problem' ;
         210..214 : s := 'Object problem' ;
         else       s := 'USER ERR ';
         end;
     DOSErrStrBig := 'DOS Error('+integerstr(err,4)+') '+s+'. ';
     end;


{section  DumpRecBufInHexO }
Procedure DumpRecBufInHexO(recnum : longint; recsiz : integer; var rec; OUTP : OUTProc_type);
              {[DEBUG] Dumps a record buffer in HEX, user supplied I/O }

var l,rs : longint;
    rbuf : array[1..2048] of byte;
    zbuf : array[1..16] of byte;
    i,j  : integer;
     begin
     i := 1; rs := recsiz;
     if rs > sizeof(rbuf) then rs := sizeof(rbuf);
     fillchar(rbuf,sizeof(rbuf),0);
     move(rec,rbuf,rs);
     l := (recnum-1)*recsiz;
     OUTP('Record - '+longintstr(recnum,7)+'    size='+integerstr(rs,4)+
             '    fileaddr:'+longintstr(l,7));
     while i < recsiz do
          begin
          move(rbuf[i],zbuf,16);
          OUTP(Buf16ToHexStr(i,(recsiz-i)+1,zbuf,false));
          i := i + 16;
          end;
     if recsiz > 16 then OUTP(' ');
     end;


{section  DumpRecBufInHex }
Procedure DumpRecBufInHex(recnum : longint; recsiz : integer; var rec);
            {[DEBUG] Dumps a record buffer in HEX }
     begin
     DumpRecBufInHexO(recnum,recsiz,rec,OUTProc);
     end;


{section  EquivalentFile }
Function  EquivalentFile(fn1,fn2 : string) : boolean;
var same : boolean;
    sr1, sr2 : searchrec;
     begin
     same := false;
     if (fileInfo(fn1,'',sr1) = 0) and
        (fileInfo(fn2,'',sr2) = 0) then
          begin
          if (sr1.size = sr2.size) and
             (sr1.time = sr2.time) then same := true;
          end;
     EquivalentFile := same;
     end;


{section  EraseFile }
Procedure EraseFile(s : string);
var f : file;
    ch : char;
    begin
    assign (f,s);
    {$I-}
    reset (f);
    {$I+}
    if IOResult = 0 then
        begin
        close(f);
        Erase(f);
        end;
    end;


{section  ExtractDelimitedStr }
Function  ExtractDelimitedStr(var s : string; lchar,rchar : char) : string;
                       {[STRING] extracts inside of a delimited substring }
var i,j  : integer;
    s1   : string;
     begin
     ExtractDelimitedStr :=  '';
     i := pos(lchar,s);
     if i > 0 then
          begin
          j := pos(rchar,s);
          if (j > i) then
               begin
               s1 :=  CopyRemove(s,i,j);
               delete(s1,1,1);
               if length(s1) > 0 then delete(s1,length(s1),1);
               ExtractDelimitedStr :=  s1;
               end;
          end;
     end;


{section ExtractPath }
Function ExtractPath(var fname : string) : string;
var i : integer;
    npath : string;
    begin
    npath := '';
    i := pos('\',fname);
    while i > 0 do
         begin
         npath := npath + copy(fname,1,i);
         delete(fname,1,i);
         i := pos('\',fname);
         end;
    ExtractPath := npath;
    end;


{section FileDate }
Function FileDate(fname : string; ext : string) : longint;
var l : longint;
    fn : string;
    SR : searchrec;
     begin
     fn := fname;
     l := 0;
     if ext <> '' then ForceExt(fn,ext);
     FindFirst(fn,anyfile,SR);
     if dosError = 0 then l := SR.time;
     FileDate := l;
     end;


{section FileBytes }
Function FileBytes(fname : string; ext : string) : longint;
var l : longint;
    fn : string;
    SR : searchrec;
     begin
     fn := fname;
     l := 0;
     if ext <> '' then ForceExt(fn,ext);
     FindFirst(fn,anyfile,SR);
     if dosError = 0 then l := SR.size;
     FileBytes := l;
     end;


{section FileExists }
Function FileExists(FName : String) : boolean;
var f     : file;
    fAttr : word;
     begin
     assign(f, FName);
     GetFAttr(f, fAttr);
     FileExists := (DosError = 0)
          { and ((fAttr and Directory) = 0)} {took out 7/14/94 }
           and ((fAttr and VolumeID)  = 0)
     end;  { FileExists }


{section FileExistsMsg }
Function FileExistsMsg(fname : string; yesmsg,nomsg : string) : boolean;
           {[FILE] Checks file existance and writes appropriate MSG if not "" }
     begin
     FileExistsMsg := true;
     if fileexists(fname) then
          begin
          if yesmsg <> '' then
               writeln('File exists [',fname,']  ',yesmsg);
          FileExistsMsg := true;
          end
     else begin
          if nomsg <> '' then
               writeln('File does not exist [',fname,']  ',nomsg);
          FileExistsMsg := false;
          end;
     end;


{section FileInfo }
Function FileInfo(filespec : string; ext : string;
                   var SR : searchrec) : integer;
var fn : string;
    err : integer;
     begin
     err := 0;
     fn := filespec;
     if ext <> '' then ForceExt(fn,ext);
     FindFirst(fn,anyfile,SR);
     FileInfo := dosError;
     end;


{section  FileExtStr }
Function  FileExtStr(fname : string) : string;
var dir,nam,ext : string;
     begin
     FSplit(fname,dir,nam,ext);
     if ext[1] = '.' then delete(ext,1,1);
     FileExtStr := ext;
     end;


{section  FileNameStr }
Function  FileNameStr(fname : string) : string;
var dir,nam,ext : string;
     begin
     FSplit(fname,dir,nam,ext);
     FileNameStr := nam + ext;
     end;


{section  FilePathStr }
Function  FilePathStr(fname : string) : string;
var dir,nam,ext : string;
     begin
     FSplit(fname,dir,nam,ext);
     FilePathStr := dir;
     end;


{section  FileRootStr }
Function  FileRootStr(fname : string) : string;
var dir,nam,ext : string;
     begin
     FSplit(fname,dir,nam,ext);
     FileRootStr := nam;
     end;


{section FindAndReplaceStr }
Function FindAndReplaceStr(str,fstr,rstr : string; both,all : boolean) : string;
                 {[STRING] finds fstr replaces with rstr, options}
var s,s1,f1s : string;
    i,j    : integer;
    ok : boolean;
     begin
     s   := str;
     if both then
          begin
          f1s := UpCaseStr(fstr);
          s1  := UpCaseStr(s);
          end
     else begin
          f1s := fstr;
          s1  := s;
          end;
     ok := true;
     j := 0;
     while ok do
          begin
          i := pos(f1s,s1);
          if (i > 0) and (j < i) then    {recursion problem}
               begin
               j := i;
               delete(s,i,length(f1s));
               insert(rstr,s,i);
               delete(s1,i,length(f1s));
               insert(rstr,s1,i);
               end
          else ok := false;
          if not all then ok := false;
          if i > 200 then ok := false;  { by 'a' -> 'aa' }
          end;
     FindAndReplaceStr := s;
     end;


{SECTION FmtAddress }
Function FmtAddress( a : longint; l : integer; flag : boolean) : string;
          {[STRING] formats a longint optionally as hex - for DUMP }
var s : string;
    x : byte;
     begin
     if not Flag then
          s := LongIntStr(a,l)
     else begin
          s := '  ';
          x := byte(a div 256);
          s := s + ByteToHex(x);
          x := byte(a AND $FF);
          s := s + ByteToHex(x);
          end;
     FmtAddress := s;
     end;



{section FmtChr }
Function FmtChr(b : byte) : string;
var s : string[5];
    begin
    s := '<--->';
    case b of
        0..31, 127  : s := '<' + FmtCvtChr(b) + '>';
        32..126     : s :=  chr(b);
        160..254    : begin
                      str(b:3,s);
                      s := '<' + s + '>';
                      end;
       end;
    FmtChr := s;
    end;


{section FmtCvtChr }
Function FmtCvtChr(b : byte) : string;
var s : string[3];
    begin
    s := '---';
    case b of
        0  : s := 'NUL';
        1  : s := 'SOH';
        2  : s := 'STX';
        3  : s := 'ETX';
        4  : s := 'EOT';
        5  : s := 'ENQ';
        6  : s := 'ACK';
        7  : s := 'BEL';
        8  : s := 'BS ';
        9  : s := 'HT ';
       10  : s := 'LF ';
       11  : s := 'VT ';
       12  : s := 'FF ';
       13  : s := 'CR ';
       14  : s := 'SO ';
       15  : s := 'SI ';
       16  : s := 'DLE';
       17  : s := 'DC1';
       18  : s := 'DC2';
       19  : s := 'DC3';
       20  : s := 'DC4';
       21  : s := 'NAK';
       22  : s := 'SYN';
       23  : s := 'ETB';
       24  : s := 'CAN';
       25  : s := 'EM ';
       26  : s := 'SUB';
       27  : s := 'ESC';
       28  : s := 'FS ';
       29  : s := 'GS ';
       30  : s := 'RS ';
       31  : s := 'US ';
       127 : s := 'DEL';
       else  begin
             if b > 31 then s := chr(b) + '  ';
             end;
       end;
    FmtCvtChr := s;
    end;


{section  FmtHMS }
Function  FmtHMS(hr, mn, sc : word) : string;
var s : string[8];
    l : longint;
     begin
     s := '        ';
     l := (hr+onehundred)*tenthousand + mn*onehundred +sc;
     str(l:8,s);
  {   if s[3] = '0' then s[3] := ' '; }
     FmtHMS :=  s[3] + s[4] + ':' + s[5] + s[6] + ':' +  s[7] + s[8];
     end;


{section  FmtKstr }
Function  FmtKstr(l : longint) : string;
var s : string[10];
     begin
     s := '**';
     str((l div $400),s);
     FmtKstr := s + 'k';
     end;


{section  FmtKstrComma }
Function  FmtKstrComma(l : longint) : string;
var s : string;
     begin
     s := '**';
     str((l div $400),s);
     if length(s) > 3 then insert(',',s,length(s)-2);
     FmtKstrComma := s + 'k';
     end;


{section FmtStr }
Function FmtStr(s : string) : string;
var s1 : string;
    i : integer;
     begin
     s1 := '';
     if length(s) > 0 then for i := 1 to length(s) do
          begin
          s1 := s1 + FmtChr(ord(s[i]));
          end;
     fmtStr := s1;
     end;


{section  FmtYMD }
Function  FmtYMD(Yr, Mo, Da : word) : string;
var s : string;
    l : longint;
     begin
     l := yr*tenthousand + mo*onehundred +da;
     str(l:8,s);
     if s[5] = '0' then s[5] := ' ';
     FmtYMD :=  s[5] + s[6] + '/' + s[7] + s[8] + '/' +  s[3] + s[4];
     end;


{section  ForceExt }
Procedure ForceExt(var fname : string; ext : string);
var i : integer;
    begin
    i := pos('.',fname);
    if i > 0 then fname := copy(fname,1,i-1);
    if ext[1] = '.' then fname := fname + ext
    else fname := fname + '.' + ext;
    end;


{section  ForcePath }
Procedure ForcePath(var fname : string; pathname : string);
var i : integer;
    xpath,path : string;
    begin
    path  := pathname;
    xpath := ExtractPath(fname); { take out path and throw away}
    if path = '' then
         begin
         getdir(0,xpath);
         path := addbackslash(defaultdrivestr)+xpath;
         end;
    i := pos('.',pathname);
    if i > 0 then path  := ExtractPath(pathname); { keep the path part }
    fname := addbackslash(path) + fname;
    end;



{section ForceRenameFile }
Function ForceRenameFile(fname1,fname2 : string) : boolean;
                  {[FILE] Erases file 2 first. }
     begin
     ForceRenameFile := false;
     EraseFile(fname2);
     if RenameFile(fname1,fname2) then ForceRenameFile := true;
     end;


{section ForceRenameToBak }
Function ForceRenameToBAK(fname : string) : boolean;
var fn1 : string;
     begin
     ForceRenameToBAK := true;
     fn1 := fname;
     ForceExt(fn1,'BAK');
     if not ForceRenameFile(fname,fn1) then
          begin
          ForceRenameToBAK := false;
          writeln('unable to rename [',fname,']  to [',fn1,']');
          end;
     end;


{section  FormatDTime }
Function  FormatDTime : string;
var Yr, Mo, Da, dow   : word;
    Hr, Mn, Sc, sc100 : word;
    begin
    GetDate(yr,mo,da,dow);
    GetTime(hr,mn,sc,sc100);
    FormatDTime :=  FmtYMD(yr,mo,da) + ' ' + FmtHMS(hr,mn,sc);
    end;


{section  FormatDTime00 }
Function  FormatDTime00 : string;
var Yr, Mo, Da, dow   : word;
    Hr, Mn, Sc, sc100 : word;
    begin
    GetDate(yr,mo,da,dow);
    GetTime(hr,mn,sc,sc100);
    FormatDTime00 :=  FmtYMD(yr,mo,da) + ' ' + FmtHMS(hr,mn,sc)+
                      '.' + integerstr(sc100+100,2);
    end;


{section GetNumber }
Function GetNumber( var astring : string) : real;
var x       : real;
    bstring : string;
    error   : integer;
    begin
    x := 0;
    bstring := GetString(astring);
    if length(bstring) > 0 then
        begin
        val(bstring,x,error);
        if (error <> 0) then
            writeln(' val conversion error  * ',bstring,' *  ',error);
        end;
    GetNumber := x;
    end;



{section  GetSTring }
Function  GetString ( var s : string) : string;
var s1 : string;
    i,l     : integer;
     begin
     i := pos(',',s);
     if i > 0 then
          begin
          GetString := copy(s,1,i-1);
          delete(s,1,i);
          end
     else begin
          GetString := s;
          s := '';
          end;
     end;



{section  HexAddressToLongInt }
Function  HexAddressToLongInt(s : string) : longint;
var l1,l2,l : longint;
    s1,s2 : string[5];
    i    : integer;
     begin
     i := pos(':',s);
     if i > 0 then
          begin
          s1 := copy(s,1,i-1);
          s2 := copy(s,i+1,length(s)-i);
          end
     else begin
          s1 := '';
          s2 := s;
          end;
     l1 := hextolongint(s1);
     l2 := hextolongint(s2);
   {  writeln('hexaddresstolongint [',s1,'] [',s2,'] ',l1,'  ',l2);}
     HexAddressToLongInt := (l1 * 16) + l2;
     end;


{section  HexToByte }
Function  HexToByte( st : string) : byte;
var  s     : string[3];
     b1,b2     : byte;
     begin
     HexToByte := 0;
     s := st;
     if s[1] = '$' then delete(s,1,1);
     if length(s) < 2 then exit;
     if ord(s[1]) < ord('A') then b1 := ((ord(s[1])-48)and $F)
     else b1 := ((ord(s[1])-55) and $F);
     if ord(s[2]) < ord('A') then b2 := ((ord(s[2])-48)and $F)
     else b2 := ((ord(s[2])-55) and $F);
     HexToByte := (b1 * 16) + b2;
     end;


{section  HexCharToByte }
Function  HexCharToByte( chr : char) : byte;
var b : byte;
    ch : char;
     begin
     ch := UpCase(chr);
     if ord(ch) < ord('A') then b := ((ord(ch)-48)and $F)
     else b := ((ord(ch)-55) and $F);
     HexCharToByte := b;
     end;


{section  HexToLongInt }
Function  HexToLongInt(s : string) : longint;
var l1,l : longint;
    ll   : byte;
    s1   : string[6];
    nibble : string;
     begin
     s1 := s;
     ll := length(s1);
     if (ll div 2) * 2 <> ll then s1 := '0' + s1;
     l  := 0;
     while length(s1) > 0 do
          begin
          nibble := s1;
          delete(s1,1,2);
          l1 := hextobyte(nibble);
          l := l * $100 + l1;
          end;
     HexToLongInt := l;
     end;


{section  Int2Real }
Function  Int2Real(i : Integer) : real;
var y     : real;
     begin
     y := i;
     Int2Real := y / 8.0;
     end;


{section IntegerStr }
Function IntegerStr( I : integer; L : integer ) : string;
var S : string;
    begin
    Str(I,S);
    IntegerStr := RightStr(S,L);
    end;


{section LeftStr }
Function LeftStr( St : string; L : integer ) : string;
     begin
     LeftStr := copy(St+conststr(' ',L-length(St)),1,l);
     end;


{section LJStr }
Function LJStr(s : string; w : byte) : string;
           {[STRING] Left justifies a string in a field of specified width }
var NewStr : string;
     begin
     FillChar(NewStr, SizeOf(NewStr), ' ');
     NewStr    := s;
     NewStr[0] := CHR(w);
     LJStr     := NewStr
     end;


{section  LongIntStr }
Function  LongIntStr( I : longint; L : integer ) : string;
var S : string;
    begin
    Str(I,S);
    LongintStr := RightStr(S,L);
    end;


{section MakeDir }
Function MakeDir(dirname : string) : boolean;
                 {[FILE] does MD <dir> command }
var fn : string;
    err : integer;
     begin
     fn := DeleteBackSlash(FilePathStr(dirname));
     {writeln('MakeDir [',fn,']');}
     {$I-} MkDir(fn); {$I+}
     err := IOResult;
     if err <> 0 then writeln('MakeDir failed ',err);
     MakeDir := fileexistsMSG(fn+'.','','Dir not Found');
     end;


{section MAX }
Function Max(i1,i2 : integer) : integer;
     begin
     if i1 < i2 then max := i2
     else max := i1;
     end;


{section MergeStr }
Function MergeStr( s : string; posn : integer; s1 : string) : string;
var i,j,n,p : integer;
    st      : string;
    begin
    st := s;
    p := posn;
    if p < 1 then p := 1;
    if (p > 253) then exit;
    i := length(s1);
    n := p+i-1;
    if n > 253 then i := 253 - n;
    if n > length(st) then st := leftstr(st,n);
    move(s1[1],st[p],i);
    Mergestr := st;
    end;


{section MIN }
Function Min(i1,i2 : integer) : integer;
     begin
     if i1 < i2 then min := i1
     else min := i2;
     end;


{section  MiscDelayNTicks }
Procedure MiscDelayNTicks(n : longint);
      {[DATETIME] A delay of 1 seems to be about 0.05 seconds}
var j : integer;
    t : longint;
     begin
     if n = 0 then exit;
     for j := 1 to n do
          begin
          t := TicksSinceMidnight;
          while TicksSinceMidnight = t do begin end;
          end;
     end;


{section  NumericsOnlyStr }
Function  NumericsOnlyStr(s : string) : string;
var i  : integer;
    s1 : string;
     begin
     s1 := '';
     if length(s) > 0 then
          begin
          for i := 1 to length(s) do
              if s[i] in ['0'..'9','-'] then s1 := s1 + s[i];
          end;
     NumericsOnlyStr := s1;
     end;



{section  PackTimeStr }
Function  PackTimestr(PT : longint) : string;
var d : DateTime;  { DOS }
var temp : string[14];
    begin
    UnPackTime(PT,d);
    temp :=  FmtYMD(d.year,d.month,d.day) + ' ' +
                    FmtHMS(d.hour,d.min,d.sec);
    PackTimestr := temp;
    end;


{section  Pad }
Function  Pad(n : integer) : string;
           {[MISC] - Generates a string of n blanks }
var i : integer;
    s : string;
     begin
     if n < 1 then s := ''
     else s := conststr(' ',n);
     Pad := s;
     end;


{section  PatchStr }
Procedure PatchStr(var s : string; ch1,ch2 : char);
var i : integer;
    begin
    i := 1;
    while i <= length(s) do
         begin
         if s[i] = ch1 then s[i] := ch2;
         inc(i);
         end;
    end;


{section PctStr }
Function PctStr(x,y : real; L,D : integer) : string;
var s : string;
    z : real;
     begin
     z := (x/(y+0.00001)) * 100;
     if z > 9999 then z := 9999;
     s := realstr(z,L,D);
     PctStr := s + '%';
     end;


{section ProperName }
Function ProperName(s : string) : string;
{ Converts a string to lower case characters and capitalizes first letter}
var i : integer;
    b : byte;
     begin
     s := DnCaseStr(s);
     s[1] := Upcase(s[1]);
     ProperName := s;
     end;


{section  QT }
Function  QT(s : string) : string;    { makes a string with quotes around it }
     begin
     QT := '''' + s + '''';
     end;


{section  RandomInt }
Function  RandomInt(i1,i2 : integer) : integer;
             {[MISC] Returns random integer  i1 <= i <= i2  }
var i,j2 : integer;
     begin
     j2 := abs(i2-i1);
     randomize;
     i := trunc(random(j2)) + i1;
     if i < 1 then i := i1
     else if i > i2 then i := i2;
     RandomInt := i;
     end;


{section Real2Int }
Function Real2Int(x : real) : Integer;
{ pack reals in range -4095 to +4095 to an integer }
{ resolution is to 1/8                             }
var y     : real;
    l     : longint;
     begin
     Real2Int := 0;
     l := abs(trunc(x*8));
     if (l > 32760) then l := 32760;
     if x < 0 then l := -1 * l;
     Real2Int := l;
     end;


{section RealStr }
Function RealStr( R : real; L,D : integer ) : string;
var S : string;
    begin
    Str(R:12:D,S);
    RealStr := RightStr(S,L);
    end;


{section RealZero }
Function RealZero( x : real) : boolean;
     begin
     if abs(x) < 0.01 then RealZero := true
     else RealZero := false;
     end;


{section  RemoveBlanks }
Procedure RemoveBlanks(var astring : string);
var j : integer;
    begin
    j := 1;
    while j <= length(astring) do
        begin
        if (astring[j] = ' ') then delete(astring,j,1)
        else inc(j);
        end;
    end;


{section RemoveBrackets }
Function RemoveBrackets(s : string) : string;
var len : integer;
    s1  : string;
    begin
    len := length(s);
    s1  := trimstr(s);
    if len > 2 then
         begin
         case s1[1] of
             '[' :  begin
                    if s1[len] = ']'   then RemoveEnds(s1);
                    end;
             '{' :  begin
                    if s1[len] = '}'   then RemoveEnds(s1);
                    end;
             '(' :  begin
                    if s1[len] = ')'   then RemoveEnds(s1);
                    end;
             '''' : begin
                    if s1[len] = ''''  then RemoveEnds(s1);
                    end;
             '"'  : begin
                    if s1[len] = '"'   then RemoveEnds(s1);
                    end;
             '<'  : begin
                    if s1[len] = '>'   then RemoveEnds(s1);
                    end;
             else   begin end;
             end;
         end;
     RemoveBrackets := s1;
     end;


{section  RemoveEnds }
Procedure RemoveEnds(var s : string);
     begin
     if length(s) < 2 then exit;
     delete(s,1,1);
     delete(s,length(s),1);
     end;


{section  RemoveExcessBlanks }
Procedure RemoveExcessBlanks(var astring : string);
var prev : char;
    j    : integer;
    begin
    prev := ' ';
    j := length(astring);
    if j > 0 then
        begin
        j := 1;
        repeat
            begin
            if (astring[j] = ' ') and (prev = ' ') then delete(astring,j,1)
            else
                begin
                prev := astring[j];
                j := j + 1;
                end;
            end;
        until j > length(astring);
        end;
    end;


{section  RemoveLeading }
Procedure RemoveLeading(var s : string; ch : CHAR);
var P : Byte;
     begin
     P := 1;
     while (S[P] = ch) and (P <= length(S)) DO Inc(P);
     if P > 1 then
          begin  { equiv to delete(s,1,P) }
          Move(S[P], S[1], succ(length(S) - P));
          Dec(S[0], pred(P));
          end;
     end;


{section  RemoveTrailing }
Procedure RemoveTrailing(var s : string; ch : CHAR);
{ Remove specified trailing characters from string }
       begin
       while S[length(S)] = ch DO Dec(S[0]);
       end;


{section RenameFile }
Function RenameFile(fname1,fname2 : string) : boolean;
                  {[FILE] Returns false if fails. }
var fil : file;
    err : integer;
     begin
     RenameFile := false;
     assign(fil,fname1);
     {$I-} rename(fil,fname2); {$I+}
     err := IOResult;
     if err = 0 then RenameFile := true
     else writeln('RenameFile error ',err);
     {$I-} close(fil); {$I+}
     err := IOResult;  {ignore error on close}
     end;


{section  ReplaceStr }
Procedure ReplaceStr( var Str : string; Offset : integer; S1 : string);
     begin
     Str := Str + conststr(' ',offset-length(Str));
     Delete(Str,Offset,length(S1));
     Insert(S1,Str,Offset);
     end;


{section RightStr }
Function RightStr( St : string; l : integer ) : string;
var S : string;
     begin
     s := conststr(' ',L-length(St))+St;
     RightStr := copy(s,(length(s)-l)+1,l);
     end;


{section RJStr }
Function RJStr(s : string; w : byte) : string;
          {[STRING] Right justifies a string in a field of specified width }
var NewStr : string;
     begin
     NewStr := s;
     while length(NewStr) < w do
          insert(' ', NewStr, 1);
     RJStr := NewStr
     end;



{section  RotateStringL }
Procedure RotateStringL(var st : string);
var ch :char;
     begin
     ch := st[1];
     delete(st,1,1);
     st := st + ch;
     end;



{section  SameFile }
Function  SameFile(fn1,fn2 : string) : boolean;
var same : boolean;
    sr1, sr2 : searchrec;
     begin
     same := false;
     if (fileInfo(fn1,'',sr1) = 0) and
        (fileInfo(fn2,'',sr2) = 0) then
          begin
          if (sr1.size = sr2.size) and
             (sr1.time = sr2.time) and
             (sr1.name = sr2.name) then same := true;
          end;
     SameFile := same;
     end;


{section  SetDateBytes }
Procedure SetDateBytes(var yr,mo,dy : byte);
var year,month,day,doy : word;
     begin
     getdate(year,month,day,doy);
     yr := year-1900;
     mo := month;
     day := dy;
     end;


{section SizeofFile }
Function SizeofFile(fname : string; ext : string) : longint;
var l : longint;
    fn : string;
    SR : searchrec;
     begin
     fn := fname;
     l := 0;
     if ext <> '' then ForceExt(fn,ext);
     FindFirst(fn,anyfile,SR);
     if dosError = 0 then l := SR.size;
     SizeofFile := l;
     end;


{section  StrBool }
Function  StrBool (s : string) : boolean;
var x : boolean;
    s1 : string;
    code : integer;
     begin
     x := true;
     s1 := UpCaseStr(s);
     if (s1 = 'NO') or (s1 = 'OFF') then x := false;
     StrBool := x;
     end;


{section  StrCal }
Procedure StrCal(ds : string; var dd,mm,yy : integer);
var s,ss : string[8];
    i,l : word;
    err,defyear,defmonth,defday : word;
    begin
    s := ds;
    getdate(defyear,defmonth,defday,err);
    defyear := defyear mod 100;
    l := length(s);
    if l = 0 then
         begin
         dd := defday;
         mm := defmonth;
         yy := defyear;
         exit;
         end;
    for i := 1 to l do if s[i] = '-' then s[i] := '/';
    for i := 1 to l do
         if not (s[i] in ['0'..'9','/']) then s[i] := ' ';
    removeblanks(s);
    while length(s) <> 8 do
        begin
        if s[2] = '/' then
             begin
             s := '0' + s;
             l := length(s);
             end;
        case l of
            1..2   :  begin         { d,dd }
                      s := integerstr(defmonth,2) + '/' + s;
                      s := s + '/' + integerstr(defyear,2);
                      removeblanks(s);
                      end;

            3..5   :  begin  {m/d,mm/d,mm/dd - add year}
                      s := s + '/' + integerstr(defyear,2);
                      removeblanks(s);
                      end;

            7      :  begin   {mm/d/yy, mm/dd/y}
                      if      s[5] = '/' then insert('0',s,4)
                      else if s[6] = '/' then insert('0',s,6)
                      else s := '01/01/01';
                      end;
            8       : begin end;

            else s := '01/01/01';
            end;
        l := length(s);
        end;
    ss := copy(s,1,2);
    val(ss,mm,err);
    ss := copy(s,4,2);
    val(ss,dd,err);
    ss := copy(s,7,2);
    val(ss,yy,err);
    end;


{section  StrByte }
Function  StrByte(s : string) : byte;
var  x,err  : integer;
     begin
     x := 0;
     val(s,x,err);
     if err > 1 then val(copy(s,1,err-1),x,err);
     StrByte := byte(x);
     end;


{section  StrInt }
Function  StrInt(s : string) : integer;
var  x,err  : integer;
     begin
     x := 0;
     val(s,x,err);
     if err > 1 then val(copy(s,1,err-1),x,err);
     StrInt := x;
     end;


{section  StrLong }
Function  StrLong(s : string) : longint;
var  err  : integer;
     x    : longint;
     begin
     x := 0;
     val(s,x,err);
     if err > 1 then val(copy(s,1,err-1),x,err);
     StrLong := x;
     end;


{section  StrReal }
Function  StrReal(s : string) : real;
var  err  : integer;
     x    : real;
     begin
     x := 0;
     val(s,x,err);
     if err > 1 then val(copy(s,1,err-1),x,err);
     StrReal := x;
     end;


{section  SuggestExt }
Procedure SuggestExt(var fname : string; ext : string);
                        {[FILE] only if EXT not specified}
var i : integer;
    begin
    i := pos('.',fname);
    if (i = 0) or (i = length(fname)) then ForceExt(fname,ext);
    end;


{section TicksSinceMidnight }
Function TicksSinceMidnight : longint;
var hr,mn,sc,sc100 : word;
     begin
     GetTime(hr,mn,sc,sc100);
     TicksSinceMidnight := sc100 + (sc * onehundred) +
                                   (mn * 60 * onehundred) +
                                   (hr * 36 * tenthousand);
     end;


{section TicksToSecs }
Function TicksToSecs ( t : longint ) : real;
     begin
     TicksToSecs := t / 100.0;
     end;


{section TicksToSecsStr }
Function TicksToSecsStr ( t : longint ) : string;
var hr,mn,sc,tk : word;
    tx          : longint;
     begin
     mn := 0;     sc := 0;     tk := 0;
     tx := t;
     hr := word(tx div 360000);
     tx := tx -  (hr * 360000);
     if tx > 0 then
          begin
          mn := word(tx div 6000);
          tx := tx -  (mn * 6000);
          if tx > 0 then
               begin
               sc := word(tx div 100);
               tx := tx -  (sc * 100);
               end;
          tk := word(tx);
          end;
     TicksToSecsStr :=  FmtHMS(hr,mn,sc)+'.'+integerstr(tk+100,2);
     end;


{section TimerSecs }

var TimerHold : longint;

Procedure TimerSecsReset;
       {[TIME] Manual Reset for TimerSecs. }
     begin
     TimerHold := 0;
     end;


Function TimerSecs : Integer;
       {[TIME] A small rough timer, Resets itself each 1000 seconds. }
var x,y : longint;
     begin
     x := TicksSinceMidnight;
     if (x < TimerHold) then TimerHold := TicksSinceMidNight;
     y := x - TimerHold;
     if (y > 100000) then
          begin
          TimerHold := TicksSinceMidNight;
          y := x - TimerHold;
          end;
     TimerSecs := integer(y div 100);
     end;




{section  Trim }
Procedure Trim(var s : string);
var i : integer;
     begin
     RemoveTrailing(s,' ');
     RemoveLeading(s,' ');
     end;


{section TrimStr }
Function TrimStr(s : string) : string;
var s1 : string;
     begin
     s1 := s;
     trim(s1);
     TrimStr := s1;
     end;


{section UnCompressStr }
Function UnCompressStr(s : string) : string;
var ls,j,k,rc : integer;
    s2      : string;
    ch      : char;
    begin
    ls := length(s);
    s2 := '';
    j := 1;
    while j <= ls  do
        begin
        if (ord(s[j]) < (160+1)) then s2 := s2 + s[j]
        else
            begin
            ch := s[j-1];
            rc := ord(s[j]) - 160;
            for k := 1 to rc do s2 := s2 + ch;
            end;
        inc(j);
        end;
    UnCompressStr := s2;
    end;


{section  UnQT }
Function  UnQT(s : string) : string;    { removes quotes from around a string }
var s1 : string;
     begin
     s1 := s;
     if s1[1] = '''' then delete(s1,1,1);
     if s1[length(s1)] = '''' then delete(s1,length(s1),1);
     UnQT := s1;
     end;



{section UpCaseStr }
Function UpCaseStr(s : STRING) : string;
{ Converts a string to upper case characters }
var i : integer;
     begin
     for i := 1 to length(s) do
         s[i] := UpCase(s[i]);
     UpCaseStr := s
     end;


{section VolumeLabel }
Function VolumeLabel( drive : string) : string;
var SR : searchrec;
     begin
     FindFirst(drive+'*.*',VolumeID,SR);
     if (DOSError = 0) then
          VolumeLabel := SR.Name
     else VolumeLabel := '';
     end;